home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / top / module-table.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  3.6 KB  |  104 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; This is similar to symbol-table.scm except that this maintains the
  3. ;;; set of modules which form a program.
  4.  
  5. ;;; The following functions deal with the module table (*modules*):
  6.  
  7. ;;;  (initialize-module-table) - this clears out all modules from the
  8. ;;;      symbol table.  Every compilation should start with this.
  9. ;;;  (add-modules-to-environment modules) - this takes a module asts,
  10. ;;;      either from a .exp file or previous compilation with the same
  11. ;;;      incarnation of the compiler and adds it to the set of `known'
  12. ;;;      modules.
  13. ;;;  (add-module-to-program module)
  14. ;;;  (locate-module name) 
  15. ;;;      return the module, interface or implementation,
  16. ;;;  (get-interface-modules
  17.  
  18. (define (initialize-module-table)
  19.   (setf *modules* (make-table))
  20.   (setf *implementations* '())
  21.   (setf *interfaces* '())
  22.   (setf *modules-being-compiled* '()))
  23.  
  24. (define (add-modules-to-environment mods)
  25.   (dolist (mod mods)
  26.     (let ((old-mod (table-entry *modules* (module-name mod))))
  27.       (unless (eq? mod old-mod)
  28.         (cond ((not old-mod)
  29.            (setf (table-entry *modules* (module-name mod)) mod)
  30.            (if (interface-module? mod)
  31.            (push mod *interfaces*)
  32.            (push mod *implementations*)))
  33.           ((interface-module? old-mod)
  34.            (if (interface-module? mod)
  35.            (multiple-interface-error mod old-mod)
  36.            (begin
  37.              (push mod *implementations*)
  38.              (setf (table-entry *modules* (module-name mod))
  39.                mod))))
  40.           ((not (interface-module? mod))
  41.            (multiple-implementation-error mod old-mod))
  42.           (else ; must be an interface for an implementation
  43.                 ; ignore them for now (ignore separate comp issue too!)
  44.            (unless (memq mod *interfaces*)
  45.           (push mod *interfaces*))))))))
  46.  
  47. (define (multiple-interface-error mod1 mod2)
  48.   (phase-error 'multiple-interfaces
  49.            "Two different interfaces for module ~A exist."
  50.            (module-name mod1))
  51.   mod2)
  52.  
  53. (define (multiple-implementation-error mod1 mod2)
  54.   (phase-error 'multiple-interfaces
  55.            "Two different interfaces for module ~A exist."
  56.            (module-name mod1))
  57.   mod2)
  58.  
  59. ;;; This saves all interface modules in *interfaces*.  It also allows
  60. ;;; an interface to be replaced by a standard module.
  61.  
  62. (define (add-modules-to-program mods)
  63.  (setf *modules-being-compiled* (append *modules-being-compiled* mods))
  64.  (dolist (module mods)
  65.    (let* ((name (module-name module))
  66.       (old-module (table-entry *modules* name)))
  67.     (when (and old-module (not (eq? (module-type module) 'extension))
  68.            (not (interface-module? old-module)))
  69.        (signal-module-double-definition module old-module))
  70.     (setf (table-entry *modules* name) module))))
  71.  
  72. (define (locate-module name)
  73.   (table-entry *modules* name))
  74.  
  75. (define (get-all-interfaces)
  76.   *interfaces*)
  77.  
  78. (define (get-compiled-modules)
  79.   *implementations*)
  80.  
  81. (define (get-all-modules)
  82.   (append *modules-being-compiled* *implementations* *interfaces*))
  83.  
  84. ;;;  (walk-modules mod-list fn) - this calls fn for each module in the
  85. ;;;      mod-list.  It also binds the global variable *module* to the
  86. ;;;      current module, *symbol-table* to the local symbol
  87. ;;;      table.  The fixity table is also placed in a global.
  88.  
  89. (define (walk-modules mods fn)
  90.   (dolist (mod mods)
  91.     (dynamic-let ((*module* mod)
  92.           (*module-name* (module-name mod))
  93.           (*symbol-table* (module-symbol-table mod))
  94.           (*fixity-table* (module-fixity-table mod))
  95.           (*inverted-symbol-table* (module-inverted-symbol-table mod)))
  96.        (funcall fn))))
  97.  
  98. (define (signal-module-double-definition m1 m2)
  99.   (phase-error/objs 'module-double-definition (list m1 m2)
  100.       "Module ~s is defined more than once." (module-name m1) ))
  101.  
  102.  
  103.  
  104.